home *** CD-ROM | disk | FTP | other *** search
/ MacHack 1994 / MacHack 1994.toast / MacHack™94 / Talks & Papers / Timothy Knox / Help / Help Files / ATMS / • v 1.6 < prev    next >
Text File  |  1994-06-24  |  9KB  |  252 lines
  1. {differences avec v 1.5: Fonctions en assembleur}
  2.  
  3. (warn ƒ
  4.  
  5. (define (just l)
  6.   (warn () (raz))
  7.   (let [(ls&ns (creer…ls&ns l 0))]
  8.        (define *ts* (apply cell (0 ls&ns)))
  9.        (define *ns* (1 ls&ns))
  10.        (just…*tc* l)))
  11.  
  12. (define (just…*tc* l)
  13.   (let [(lc&nsmax (creer…lc&nsmax l *ns* 'dk))]
  14.        (define *tc* (apply cell (0 lc&nsmax)))
  15.        (define *nc* (1- (blength *tc*)))
  16.        (define *nsmax* (1 lc&nsmax))
  17.        (just…*tc/s&*tc/nxx* l)))
  18.  
  19. (define (just…*tc/s&*tc/nxx* l)
  20.   (letrec [((init…tc/s i t)
  21.             (cond (>? i *ns*) t
  22.                   (begin (cell=! t i (cell (makebitarray *nc*)(makebitarray *nc*)))
  23.                          (init…tc/s (1+ i) t))))
  24.            ((init…tc/nxx i t)
  25.             (cond (>? i *nsmax*) t
  26.                   (begin (cell=! t i (makebitarray *nc*))
  27.                          (init…tc/nxx (1+ i) t))))
  28.            (tc/s&tc/nxx (creer…tc/s&tc/nxx   (init…tc/s 0 (makecell (1+ *ns*) 0))
  29.                                              (init…tc/nxx 0 (makecell (+ *nsmax* 1) 0))
  30.                                              (init…tc/nxx 0 (makecell (+ *nsmax* 1) 0))
  31.                                              *tc*))
  32.            (tc…s-> (bitand (1 (1 tc/s&tc/nxx)) (0 (2 tc/s&tc/nxx))))
  33.            (tc…->s (bitand (0 (1 tc/s&tc/nxx)) (1 (2 tc/s&tc/nxx))))]
  34.           (define *tc/s* (0 tc/s&tc/nxx))
  35.           (define *msk* (bitnot! (makebitarray *nc*)))
  36.           (define *a->b* (avancer! pg *tc/s* *tc* (trouver…ts! *tc* tc…->s pd)
  37.                                         (1 tc/s&tc/nxx) (2 tc/s&tc/nxx) *msk*
  38.                                   (avancer! pd  *tc/s* *tc* (trouver…ts! *tc* tc…s-> pg)
  39.                                                        (1 tc/s&tc/nxx) (2 tc/s&tc/nxx) *msk*
  40.                                                        (cell (makebitarray *ns*) (makebitarray *ns*)))))
  41.           (define *tc/nsg* (1 tc/s&tc/nxx))
  42.           (define *tc/nsd* (2 tc/s&tc/nxx))))
  43.  
  44. (define (creer…ls&ns lc n)
  45.   (cond (null? lc) (cell () n)
  46.         (letrec [((loop ls n l&n)
  47.                   (cond (null? ls) (cell n l&n)
  48.                         (let [(s (intern 'dk (0 ls)))]
  49.                              (cond (warn () (error? (binding=? s ())))
  50.                                    (begin (binding=! s () n)
  51.                                           (let [(etc (loop (-1 ls) (1+ n) l&n))]
  52.                                                (cell (0 etc) (cell (cons (0 ls) (0 (1 etc))) (1 (1 etc))))))
  53.                                    (loop (-1 ls) n l&n)))))
  54.                  (respg (loop (pg (0 lc)) n
  55.                               (letrec [(respd (loop (pd (0 lc)) (0 respg)
  56.                                                     (creer…ls&ns (-1 lc) (0 respd))))]
  57.                                       (1 respd))))]
  58.                 (1 respg))))
  59.  
  60. {••• Traduit une liste de symboles en un vecteur de bits en fonction du package dk}
  61.  
  62. (defext  ":Help Files:ATMS:fo" "traduire" traduire
  63.   (cell 'traduire ())
  64.  %111 l ba dk)
  65.  
  66. (defext ":Help Files:ATMS:fo" "creer…lc&nsmax" creer…lc&nsmax 
  67.   (cell 'creer…lc&nsmax (getcode traduire) () ƒ (getcode bitcount)(getcode bcopy)(getcode bitand!)(getcode bitfind))
  68.   %111 l ns dk)
  69.  
  70. {••• bitfind et bitclr a la fois, retourne le rang}
  71.      
  72. (defext ":Help Files:ATMS:fo" "bitfclr!" bitfclr!
  73.   (cell 'bitfclr! ƒ)
  74.   %1 x)
  75.  
  76. (defext ":Help Files:ATMS:fo" "creer…tc/s&tc/nxx" creer…tc/s&tc/nxx
  77.   (cell 'creer…tc/s&tc/nxx (getcode bitfclr!) () ƒ (getcode BCopy)(getcode BitCount))
  78.   %1111 tc/s tc/nsg tc/nsd tc)
  79.  
  80. {••• Ajoute une clause dans une liste de clauses sans verification des soussommages
  81.      *tc* se retrouve dans l'ordre par rapport a la liste initiale}
  82.  
  83. (define consminimal cons)
  84.  
  85. {••• Affecte ? aux *ns* symboles de *ts* dans le package dk}
  86.  
  87. (define (raz)
  88.   (cond (warn ƒ (error? *ts*)) †
  89.         (letrec [(ns (1- (blength *ts*)))
  90.                  ((loop n)
  91.                   (cond (=? n ns) †
  92.                         (begin (binding=! (intern 'dk (n *ts*)) () (warn ƒ ?))
  93.                                (loop (1+ n)))))]
  94.                 (loop 0))))
  95.  
  96. {••• Extraordinaire barriere d'abstraction: pg partie gauche et pd partie droite}
  97.  
  98. (define pg 0)
  99. (define pd 1)
  100.  
  101. {•••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••}
  102.  
  103. (define (• lhs rhs)
  104.   (letrec
  105.    [(a (traduire lhs (makebitarray *ns*) 'dk))
  106.     (b (traduire rhs (makebitarray *ns*) 'dk))
  107.     (msk (bcopy *msk*))
  108.     (tc/nsg (bcopy *tc/nsg*))
  109.     (tc/nsd (bcopy *tc/nsd*))
  110.     (a->b (avancer! pg  *tc/s* *tc* a tc/nsg tc/nsd msk
  111.                          (avancer! pd *tc/s* *tc* b tc/nsg tc/nsd msk (ccopy *a->b*))))
  112.     (rangtt (explorer tc/nsg tc/nsd msk))]
  113.    (cond (eq? a->b †) †
  114.          (and (bitfind (0 tc/nsg)) rangtt)
  115.          (prouver…ts (bitmsk (pg (rangtt *tc*)) (pg a->b)) tc/nsg tc/nsd msk a->b *tc/s* *tc*))))
  116.  
  117. {••• retourne dans res le tas de symboles apparaissant dans la partie goud des clauses de tc}
  118.  
  119. (defext ":Help Files:ATMS:fo" "trouver…ts!" trouver…ts!
  120.   (cell 'trouver…ts! (getcode BitFClr!)(getcode BitOr!) ƒ ())
  121.   %111 *tc* tc goud)
  122.  
  123. {•••retourne le rang de la clause de tete entrainant le plus faible facteur de branchement ou ƒ}
  124.  
  125. (defext ":Help Files:ATMS:fo" "explorer" explorer
  126.   (cell 'explorer (getcode BCopy)(getcode BitAnd!)(getcode BitFind) () ƒ)
  127.   %111 tc/nsg tc/nsd msk)
  128.  
  129. {••• avance d'un cran les clauses de tc dans tc/nxx}
  130.      
  131. (defext ":Help Files:ATMS:fo" "avancer!tc" avancer!tc
  132.   (cell 'avancer!tc (getcode BitFind)(getcode BitOr!)(getcode BitAnd!)(getcode BitNot!)(getcode BCopy) ƒ ())
  133.   %11 tc tc/nxx)
  134.  
  135. {•••reclasse les clauses dans tc/nsg et tc/nsd,
  136.     en avancant dans tc/nsg (tc/nsd) les clauses qui contiennent le symbole a goud d'un cran,
  137.     en mettant a jour le msk ie eteindre les bits des clauses qui contiennent le symbole a doug
  138.     en appelant avancer! a gauche pour les symboles s dans les clauses ->s qui sont ainsi apparues
  139.     en appelant avancer! a droite pour les symboles s dans les clauses s-> qui sont ainsi apparues
  140.     Elle travaille physiquement sur chacun des tableaux et retourne a->b
  141.     L'appeler toujours avec tc=*tc* et tcs=*tc/s*}
  142.  
  143. (defext ":Help Files:ATMS:fo" "avancer!" avancer!
  144.   (cell 'avancer! (getcode avancer!tc) (getcode bitfclr!)(getcode trouver…ts!)
  145.          † ƒ () (getcode Bitand!)(getcode BitOr!)(getcode BitFind)(getcode BCopy)(getcode BitNot!))
  146.    %11111111111 goud tcs tc ts tc/nsg tc/nsd msk a->b)
  147.  
  148. {•••prouve les clauses a->gb pour tout g de gamma
  149.            L'appeler toujours avec tc=*tc* et tcs=*tc/s*}
  150.  
  151. (defext ":Help Files:ATMS:fo" "prouver…ts" prouver…ts 
  152.   (cell 'prouver…ts (getcode avancer!)(getcode bitfclr!)(getcode explorer)
  153.         (getcode Print)(getcode BitFind)(getcode BitOr!)(getcode BitAnd!)
  154.         (getcode BitNot!)(getcode BCopy) ƒ () †)
  155.   %1111111 gamma old…tc/nsg old…tc/nsd old…msk old…a->b tcs tc)
  156.  
  157. {••• un pretty print pour le rang d'une clause}
  158.  
  159. (define (ppc rang)
  160.   (cond rang (let [(c (rang *tc*))]
  161.                   (cell (ppts (pg c)) (ppts (pd c))))
  162.         "Pas de regle"))
  163.  
  164. {••• un pretty print pour un vecteur de bits representant un ensemble de clauses}
  165.  
  166. (define (pptc p)
  167.   (letrec [(ba (bcopy p))
  168.            ((loop rang)
  169.             (cond rang (cond (>? rang *nc*) ()
  170.                              (cons (ppc rang) (loop (bitfclr! ba))))
  171.                   ()))]
  172.           (loop (bitfclr! ba))))
  173.  
  174. {••• un pretty print pour le rang d'un symbole}
  175.  
  176. (define (pps rang)
  177.   (cond rang (rang *ts*) 
  178.         "Pas de symbole"))
  179.  
  180. {••• un pretty print pour un vecteur de bits representant un ensemble de symboles}
  181.  
  182. (define (ppts p)
  183.   (letrec [(ba (bcopy p))
  184.            ((loop rang)
  185.             (cond rang (cons (rang *ts*) (loop (bitfclr! ba)))
  186.                   ()))]
  187.           (loop (bitfclr! ba))))
  188.  
  189. (define (max n | l)
  190.   (cond (null? l) n
  191.         (<? n (0 l)) (apply max l)
  192.         (apply max (cons n (-1 l)))))
  193.  
  194. (defmacro (bitmsk x y)
  195.   `(bitand! ,x (bitnot! (bcopy ,y))))
  196.  
  197. (defmacro (bitand x y)
  198.   `(bitand! ,x (bcopy ,y)))
  199.  
  200. (defmacro (bitor x y)
  201.   `(bitor! ,x (bcopy ,y)))
  202.  
  203. (defmacro (bitnot x)
  204.   `(bitnot! (bcopy ,x)))
  205.  
  206. (defmacro (ccopy a->b)
  207.   `(cell (bcopy (pg ,a->b)) (bcopy (pd ,a->b))))
  208.  
  209. {accede a la valeur d'une forme suspendue si la structure en est simple.
  210. Attention: Pour un cell, elle n'accede pas a chaque element}
  211.  
  212. (defmacro (accede | l)
  213.   (cons 'begin (maplist 'null? l)))
  214.  
  215. {Imprime en sequence par prin les elements de l et retourne la valeur du premier arg}
  216.  
  217. (defmacro (prinloop val | l)
  218.   `(begin ,@(maplist 'prin l) (flushio stdo) ,val))
  219.  
  220. {le stepper s'arrete pour les ident de variables, les cons, les fermetures}
  221.  
  222. (define (step? expr env)
  223.   (or (=? (type expr) 6)
  224.       (=? (type expr) 12)
  225.       (=? (type expr) 13)
  226.   ))
  227.  
  228. (defmacro (mapause | l)
  229.   `(begin ,@(maplist 'prin l) (flushio stdo) (pause))
  230.   )
  231.  
  232. (defmacro (mapause | l) ()
  233.   )
  234.  
  235. (define (maplist f l)
  236.   (cond (null? l) ()
  237.         (cons (list f (0 l)) (maplist f (-1 l)))))
  238.  
  239. (define (instance pg pd lvar ldom test)
  240.   (letrec [((loopvar lvar ldom)
  241.             (cond (null? lvar) (cond (eval test ()) (prin (cell (eval pg ()) (eval pd ()))))
  242.                   (loopval (0 lvar) (0 ldom) (-1 lvar) (-1 ldom))))
  243.            ((loopval var dom lvar ldom)
  244.             (cond (cons? dom) (begin (binding=! var () (0 dom))
  245.                                      (loopvar lvar ldom)
  246.                                      (loopval var (-1 dom) lvar ldom))))]
  247.           (loopvar lvar ldom) (flushio stdo)))
  248.  
  249. (define (inverser l)
  250.   (cond (null? l) ()
  251.         (cons (cell (1 (0 l)) (0 (0 l))) (inverser (-1 l)))))
  252. )